home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
mpfeel.lha
/
MPFeel
/
Modules
/
initcode.em
< prev
next >
Wrap
Lisp/Scheme
|
1992-10-06
|
17KB
|
545 lines
;; Eulisp Module
;; Author: pab
;; File: initcode.em
;; Date: Mon Dec 9 22:36:26 1991
;;
;; Project:
;; Description:
;;
(defmodule initcode
(threads arith calls symbols strings characters list-operators
streams vectors lists ccc tables classes (rename ((null Null)) class-names) errors
generics others module-operators formatted-io bit-vectors
root semaphores sockets)
()
;; install the callbacks
;; define add-method
(defun simple-add-method (gf meth)
((lambda (sig table)
(if (null table)
(generic-method-table-setter gf (mk-initial-table sig (list meth)))
(add-meth-aux table sig (list meth)))
;;(if (methodp (car (find-applicable-methods gf sig)))
;;nil
;;(cerror (find-applicable-methods gf sig) nil))
;; invalidate cache
(generic-fast-method-cache-setter gf nil)
(generic-slow-method-cache-setter gf nil)
gf)
(method-signature meth)
(generic-method-table gf)))
(defun add-method-method (h1 h2 gf meth)
(simple-add-method gf meth))
(defun mk-initial-table (initkey initentry)
(fold (lambda (class tab)
(cons (cons class tab) nil))
(reverse initkey)
initentry))
;; starting this lot up...
(defun add-meth-aux (table sig meth)
((lambda (xx)
(if (null table)
;; should never happen
(swizzle)
(if (null xx)
(progn (nconc table
(fold (lambda (class tab)
(cons (cons class tab) nil))
(reverse sig)
meth))
table)
(if (null (cdr sig))
;; must have a relacement method
((setter cdr) xx meth)
(add-meth-aux (cdr xx) (cdr sig) meth)))))
(my-assq (car sig) table)))
(defun add-method-to-slow-cache (gf sig meths)
((lambda (table)
(if (null table)
(generic-slow-method-cache-setter
gf
(mk-initial-table sig (cons sig meths)))
(add-meth-aux table sig (cons sig meths)))
table)
(generic-slow-method-cache gf)))
(defun find-applicable-methods (gf sig)
(find-applic-methods-aux (generic-method-table gf)
(mapcar class-precedence-list sig)))
(export find-applicable-methods)
;; wasteful...
(defun find-applic-methods-aux (table cpl-lst)
(if (null cpl-lst)
nil
(if (null (car cpl-lst))
nil
((lambda (xx)
(if (null xx)
(find-applic-methods-aux table
(cons (cdr (car cpl-lst))
(cdr cpl-lst)))
(if (null (cdr cpl-lst))
;; found summat
(if (methodp (car (cdr xx)))
(cons (car (cdr xx))
(find-applic-methods-aux table
(cons (cdr (car cpl-lst))
(cdr cpl-lst))))
(progn (print "error-1")
(print (list xx cpl-lst))
(print "error-1")
(print (list xx cpl-lst))
nil))
(append (find-applic-methods-aux (cdr xx) (cdr cpl-lst))
(find-applic-methods-aux table
(cons (cdr (car cpl-lst))
(cdr cpl-lst)))))))
(my-assq (car (car cpl-lst)) table)))))
(defun find-and-call-generic (gf args)
(find-and-call-generic-1 gf args (mapcar class-of args)))
(defun find-and-call-generic-1 (gf args sig)
((lambda (meths)
(if (null meths)
(progn (setq x (list gf sig args))
(error "No applicable method" Internal-Error
'error-value (list gf sig)))
(progn (add-method-to-slow-cache gf sig meths)
(generic-fast-method-cache-setter gf
(cons sig meths))
(if (methodp (car meths))
(call-method-by-list meths args)
(cerror meths nil)))))
((generic-discriminator gf) sig)))
;; use this at bootstrap...
(defun default-compute-discriminating-function (gf)
(lambda (sig)
(find-applicable-methods gf sig)))
(defun compute-discriminating-function-as-method (foo bar gf)
(lambda (sig)
(find-applicable-methods gf sig)))
;; add as a method...
;; necessary functions
(defun fold (fn lst val)
(if (null lst) val
(fold fn (cdr lst)
(fn (car lst) val))))
(defun reverse (x)
(fold cons x nil))
(defun my-mapcar (fn lst)
(if (null lst) nil
(cons (fn (car lst))
(mapcar fn (cdr lst)))))
(defun my-assq (obj lst)
(if (null lst) nil
(if (eq (car (car lst)) obj)
(car lst)
(my-assq obj (cdr lst)))))
;; Should have enough in place now...
(set-compute-and-apply-fn find-and-call-generic)
;; very much hacked up bootstrap
(defun init-generic (gf)
(generic-discriminator-setter gf
(default-compute-discriminating-function gf)))
;; bung in the discriminators...
(init-generic allocate-instance)
(init-generic initialize-instance)
(init-generic compute-discriminating-function)
(init-generic add-method)
(init-generic compute-class-precedence-list)
(init-generic slot-value-using-class)
(init-generic (setter slot-value-using-class))
(init-generic slot-value-using-slot-description)
(init-generic (setter slot-value-using-slot-description))
(init-generic find-slot-description)
(init-generic make-slot-description)
(init-generic make-inherited-slot-description)
(init-generic add-slot-description)
(init-generic generic-write)
(init-generic generic-prin)
(init-generic binary-plus)
(init-generic binary-times)
(init-generic binary-difference)
(init-generic binary-divide)
(init-generic binary-gcd)
(init-generic binary-lcm)
(init-generic binary-lcm)
(init-generic =)
(init-generic zerop)
(init-generic abs)
(init-generic binary-lt)
(init-generic binary-gt)
(init-generic equal)
(init-generic copy)
(simple-add-method allocate-instance
(generic_initialize_instance\,Method
(generic_allocate_instance\,Method_Class method nil)
(list 'signature (list method-class object)
'function generic_allocate_instance\,Method_Class)))
(simple-add-method initialize-instance
(generic_initialize_instance\,Method
(generic_allocate_instance\,Method_Class method nil)
(list 'signature (list method object)
'function generic_initialize_instance\,Method)))
(simple-add-method add-method
(generic_initialize_instance\,Method
(generic_allocate_instance\,Method_Class method nil)
(list 'signature (list generic-function method)
'function add-method-method)))
;; should be enough
(add-method allocate-instance
(make-instance method
'signature (list class object)
'function
generic_allocate_instance\,StandardClass))
(add-method allocate-instance
(generic_initialize_instance\,Method
(generic_allocate_instance\,Method_Class method nil)
(list 'signature (list generic-class object)
'function generic_allocate_instance\,Generic_Class)))
(add-method initialize-instance
(generic_initialize_instance\,Method
(generic_allocate_instance\,Method_Class method nil)
(list 'signature (list generic-function object)
'function generic_initialize_instance\,Generic)))
(add-method allocate-instance
(make-instance method
'signature (list structure-class object)
'function
generic_allocate_instance\,StructureClass))
(add-method allocate-instance
(make-instance method
'signature (list slot-description-class object)
'function
generic_allocate_instance\,Slot_Description_Class))
(add-method allocate-instance
(make-instance method
'signature (list condition-class object)
'function
generic_allocate_instance\,Condition_Class))
(add-method allocate-instance
(make-instance method
'signature (list primitive-class object)
'function
generic_allocate_instance\,Primitive_Class))
(add-method initialize-instance
(make-instance method
'signature (list object object)
'function
generic_initialize_instance\,Object))
(add-method initialize-instance
(make-instance method
'signature (list class object)
'function
generic_initialize_instance\,Standard_Class))
(add-method initialize-instance
(make-instance method
'signature (list slot-description object)
'function
generic_initialize_instance\,Slot_Description))
(add-method initialize-instance
(make-instance method
'signature (list condition object)
'function
generic_initialize_instance\,Default_Condition))
;; More initting
(add-method compute-class-precedence-list
(make-instance method
'signature (list class)
'function generic_compute_class_precedence_list\,Standard_Class))
;; slot access
(add-method slot-value-using-class
(make-instance method
'signature (list class object object)
'function generic_slot_value_using_class\,Standard_Class))
(add-method slot-value-using-class
(make-instance method
'signature (list structure-class object object)
'function generic_slot_value_using_class\,Structure_Class))
(add-method (setter slot-value-using-class)
(make-instance method
'signature (list class object object object)
'function generic_slot_value_using_class_setter\,Standard_Class))
(add-method (setter slot-value-using-class)
(make-instance method
'signature (list structure-class object object object)
'function generic_slot_value_using_class_setter\,StructureClass))
(add-method slot-value-using-slot-description
(make-instance method
'signature (list object local-slot-description)
'function
generic_slot_value_using_slot_description\,Object\,Local_Slot_Description))
(add-method slot-value-using-slot-description
(make-instance method
'signature (list object local-slot-description)
'function
generic_slot_value_using_slot_description\,Object\,Local_Slot_Description))
(add-method (setter slot-value-using-slot-description)
(make-instance method
'signature (list object local-slot-description object)
'function ;; should have been called fred.
generic_slot_value_using_slot_description_setter\,Object\,Local_Slot_Description))
(add-method find-slot-description
(make-instance method
'signature (list structure-class object)
'function generic_find_slot_description\,Structure_Class))
(add-method find-slot-description
(make-instance method
'signature (list class object)
'function generic_find_slot_description\,Standard_Class))
(add-method make-slot-description
(make-instance method
'signature (list class object)
'function generic_make_slot_description\,Standard_Class))
(add-method make-inherited-slot-description
(make-instance method
'signature (list class slot-description object)
'function
generic_make_inherited_slot_description\,Standard_Class\,Slot_Description))
(add-method add-slot-description
(make-instance method
'signature (list class slot-description)
'function generic_add_slot_description\,StandardClass\,SlotDescription))
(add-method add-slot-description
(make-instance method
'signature (list class local-slot-description)
'function
generic_add_slot_description\,StandardClass\,LocalSlotDescription))
;; streams
(add-method generic-write
(make-instance method
'signature (list object object)
'function generic_generic_write\,Object))
(add-method generic-prin
(make-instance method
'signature (list object object)
'function generic_generic_prin\,Object))
(add-method generic-prin
(make-instance method
'signature (list pair object)
'function generic_generic_prin\,Cons))
;; arithmetic...
(add-method binary-plus
(make-instance method
'signature (list number number)
'function generic_binary_plus\,Number\,Number))
(add-method binary-plus
(make-instance method
'signature (list integer integer)
'function generic_binary_plus\,Integer\,Integer))
(add-method binary-difference
(make-instance method
'signature (list number number)
'function generic_binary_difference\,Number\,Number))
(add-method binary-difference
(make-instance method
'signature (list integer integer)
'function generic_binary_difference\,Integer\,Integer))
(add-method binary-times
(make-instance method
'signature (list number number)
'function generic_binary_times\,Number\,Number))
(add-method binary-times
(make-instance method
'signature (list integer integer)
'function generic_binary_times\,Integer\,Integer))
(add-method binary-divide
(make-instance method
'signature (list number number)
'function generic_binary_divide\,Number\,Number))
(add-method binary-gcd
(make-instance method
'signature (list integer integer)
'function generic_binary_gcd\,Integer\,Integer))
(add-method binary-lcm
(make-instance method
'signature (list integer integer)
'function generic_binary_lcm\,Integer\,Integer))
(add-method =
(make-instance method
'signature (list number number)
'function generic_eqn\,Number\,Number))
(add-method equal
(make-instance method
'signature (list number number)
'function generic_equal\,Number\,Number))
(add-method zerop
(make-instance method
'signature (list number )
'function generic_zerop\,Number))
(add-method abs
(make-instance method
'signature (list number)
'function generic_abs\,Number))
(add-method binary-lt
(make-instance method
'signature (list number number)
'function generic_binary_lt\,Number\,Number))
(add-method binary-gt
(make-instance method
'signature (list integer integer)
'function generic_binary_gt\,Integer\,Integer))
(add-method binary-lt
(make-instance method
'signature (list integer integer)
'function generic_binary_lt\,Integer\,Integer))
(add-method binary-gt
(make-instance method
'signature (list number number)
'function generic_binary_gt\,Number\,Number))
;; threads
;; Note that these 2 only exist in BSD+SYSV versions...
(if (eq (feel-machine-type) 'generic)
()
(progn (add-method allocate-instance
(make-instance method
'signature (list thread-class object)
'function generic_allocate_instance\,Thread_Class))
(add-method initialize-instance
(make-instance method
'signature (list thread object)
'function generic_initialize_instance\,Thread_Class))
(add-method generic-prin
(make-instance method
'signature (list thread object)
'function generic_generic_prin\,Thread\,Object))
(add-method generic-write
(make-instance method
'signature (list thread object)
'function generic_generic_write\,Thread\,Object))
))
;; form ccc.c...
(add-method equal
(make-instance method
'signature (list object object)
'function generic_equal\,Object\,Object))
(add-method equal
(make-instance method
'signature (list pair pair)
'function generic_equal\,Cons\,Cons))
(add-method equal
(make-instance method
'signature (list vector vector)
'function generic_equal\,Vector\,Vector))
(add-method equal
(make-instance method
'signature (list structure structure)
'function generic_equal\,Basic_Structure\,Basic_Structure))
(add-method equal
(make-instance method
'signature (list class class)
'function generic_equal\,Standard_Class\,Standard_Class))
(add-method copy
(make-instance method
'signature (list object)
'function generic_copy\,Object))
(add-method copy
(make-instance method
'signature (list pair)
'function generic_copy\,Cons))
(add-method copy
(make-instance method
'signature (list vector)
'function generic_copy\,Vector))
;; and lastly...
(add-method compute-discriminating-function
(make-instance method
'signature (list generic-function)
'function compute-discriminating-function-as-method))
;; end module
)